;; host/srfi.scm - (c) rohan drape, 2001-2005

;; Must provide the finalized SRFI's: 1 List, 4 Homogenous Vectors, 8
;; receive, 13 String, 14 Character Set, 18 Threads, 19 Date and Time,
;; 25 Arrays, 28 Basic Format Strings, 31 Parameters.

;; Notes: SRFI 1 redefines some values, these values are imported with
;; an s: prefix.  SRFI 19 conflicts with mzscheme primitives.  RSC
;; does not use the mzscheme primitives.  SRFI 25 provides procedures
;; not in the SRFI, exclude those defined in RSC.

(module 
 srfi mzscheme
 (require (lib  "list.ss" "srfi" "1")
	 (lib  "4.ss" "srfi")
	 (lib  "8.ss" "srfi")
	 (lib  "9.ss" "srfi")
	 (lib "11.ss" "srfi")
	 (lib "13.ss" "srfi")
	 (lib "14.ss" "srfi")
	 (all-except (lib "19.ss" "srfi") 
		     make-date 
		     date-year-day 
		     date-year 
		     date-week-day 
		     date-second
		     date-month
		     date-minute
		     date-hour
		     date-day date)
	 (all-except (lib "25.ss" "srfi") array-size)
	 (lib "26.ss" "srfi")
	 (all-except (lib "43.ss" "srfi") vector-fill! vector->list)
	 (rename (lib "43.ss" "srfi") s:vector-fill! vector-fill!))

(provide (all-from (lib  "list.ss" "srfi" "1"))
	 (all-from (lib  "8.ss" "srfi"))
	 (all-from (lib  "9.ss" "srfi"))
	 (all-from (lib  "4.ss" "srfi"))
	 (all-from (lib "11.ss" "srfi"))
	 (all-from (lib "13.ss" "srfi"))
	 (all-from (lib "14.ss" "srfi"))
	 (all-from (lib "19.ss" "srfi"))
	 (all-from (lib "25.ss" "srfi"))
	 (all-from (lib "26.ss" "srfi"))
	 (all-from (lib "43.ss" "srfi")))

;; There are some problems with this SRFI... (lib "40.ss" "srfi")

;; Must provide the withdrawn SRFI's: 33 Bitwise Operations.

;; The SRFI-18 make-thread does not start the thread, it only creates
;; it.  The 'make-thread*' variant is (thread-start! (make-thread p))

(define (make-thread p . name) 
  (error "make-thread: not implemented, use make-thread*"))
(define make-thread* thread)
(define (thread-start! thread) 
  (error "thread-start!: not implemented, use make-thread*"))
(define thread-sleep! sleep)
(define thread-join! thread-wait)
(define thread-terminate! kill-thread)

;; Must provide 'make-semaphore', 'semaphore-post', 'semaphore-wait',
;; and 'semaphore-wait/timeout'.

(define (semaphore-wait/timeout timeout semaphore)
  (sync/timeout timeout semaphore))

;; The used SRFI 1 renames are aliased to preferred variant names.

(define member* s:member)

;; SRFI-33 is withdrawn but there is a reference implementation, it
;; overlaps with the PLT primitives, and it is a good SRFI.

(define (bitwise-nand  i j)  (bitwise-not (bitwise-and i j)))
(define (bitwise-nor   i j)  (bitwise-not (bitwise-ior i j)))
(define (bitwise-andc1 i j)  (bitwise-and (bitwise-not i) j))	
(define (bitwise-andc2 i j)  (bitwise-and i (bitwise-not j)))	
(define (bitwise-orc1  i j)  (bitwise-ior (bitwise-not i) j))
(define (bitwise-orc2  i j)  (bitwise-ior i (bitwise-not j)))

(define (bitwise-eqv . args)
  (let lp ((args args) (ans -1))
    (if (pair? args)
        (lp (cdr args) (bitwise-not (bitwise-xor ans (car args))))
	ans)))

(define (%mask size) (bitwise-not (arithmetic-shift -1 size)))

(define (bit-set? index n) 
  (not (zero? (bitwise-and (arithmetic-shift 1 index) n))))

(define (any-bits-set? test-bits n) (not (zero? (bitwise-and test-bits n))))

(define (all-bits-set? test-bits n) (= test-bits (bitwise-and test-bits n)))

(define (bitwise-merge mask n0 n1)
  (bitwise-ior (bitwise-and mask n1)
	       (bitwise-and (bitwise-not mask) n0)))

(define (extract-bit-field size position n)
  (bitwise-and (%mask size) (arithmetic-shift n (- position))))

(define (test-bit-field? size position n)
  (not (zero? (bitwise-and (arithmetic-shift n (- position)) (%mask size)))))

(define (clear-bit-field size position n)
  (replace-bit-field size position 0 n))

(define (replace-bit-field size position newfield n)
  (let ((m (%mask size)))
    (bitwise-ior (bitwise-and n (bitwise-not (arithmetic-shift m position)))
		 (arithmetic-shift (bitwise-and newfield m) position))))

(define (copy-bit-field size position from to)
  (bitwise-merge (arithmetic-shift (%mask size) position) to from))

(define (first-set-bit integer)
  (and (not (zero? integer))
       (let loop ((j 0) (i integer))
         (if (bit-set? 0 i) 
	     j
             (loop (+ j 1) (arithmetic-shift i -1))))))

;; In 299.2 the u8vector->vector procedure has gone missing.  Simple
;; replacements until they return.

(define (vector->u8vector s)
  (let* ((l (vector-length s))
	 (v (make-u8vector l)))
    (do ((i 0 (+ i 1)))
	((= i l))
      (u8vector-set! v i (vector-ref s i)))
    v))

(define (u8vector->vector v) 
  (let* ((l (u8vector-length v))
	 (s (make-vector l)))
    (do ((i 0 (+ i 1)))
	((= i l))
      (vector-set! s i (u8vector-ref v i)))
    s))

;; SRFI-34

(define (with-exception-handler handler procedure)
   (with-handlers (((lambda (exn) #t)
		    (lambda (exn) (handler (exn-message exn)))))
		  (procedure)))

(provide (all-defined)))
